home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / tcl / tcl70b2.lha / tcl7.0b2 / tclLink.c < prev    next >
C/C++ Source or Header  |  1993-06-17  |  12KB  |  388 lines
  1. /* 
  2.  * tclLink.c --
  3.  *
  4.  *    This file implements linked variables (a C variable that is
  5.  *    tied to a Tcl variable).  The idea of linked variables was
  6.  *    first suggested by Andreas Stocke and this implementation is
  7.  *    based heavily on a prototype implementation provided by
  8.  *    him.
  9.  *
  10.  * Copyright (c) 1993 The Regents of the University of California.
  11.  * All rights reserved.
  12.  *
  13.  * Permission is hereby granted, without written agreement and without
  14.  * license or royalty fees, to use, copy, modify, and distribute this
  15.  * software and its documentation for any purpose, provided that the
  16.  * above copyright notice and the following two paragraphs appear in
  17.  * all copies of this software.
  18.  * 
  19.  * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  20.  * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  21.  * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  22.  * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  23.  *
  24.  * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  25.  * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  26.  * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  27.  * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  28.  * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  29.  */
  30.  
  31. #ifndef lint
  32. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclLink.c,v 1.2 93/06/17 15:25:26 ouster Exp $ SPRITE (Berkeley)";
  33. #endif /* not lint */
  34.  
  35. #include "tclInt.h"
  36.  
  37. /*
  38.  * For each linked variable there is a data structure of the following
  39.  * type, which describes the link and is the clientData for the trace
  40.  * set on the Tcl variable.
  41.  */
  42.  
  43. typedef struct Link {
  44.     Tcl_Interp *interp;        /* Interpreter containing Tcl variable. */
  45.     char *addr;            /* Location of C variable. */
  46.     int type;            /* Type of link (TCL_LINK_INT, etc.). */
  47.     int writable;        /* Zero means Tcl variable is read-only. */
  48.     union {
  49.     int i;
  50.     double d;
  51.     } lastValue;        /* Last known value of C variable;  used to
  52.                  * avoid string conversions. */
  53. } Link;
  54.  
  55. /*
  56.  * Forward references to procedures defined later in this file:
  57.  */
  58.  
  59. static char *        LinkTraceProc _ANSI_ARGS_((ClientData clientData,
  60.                 Tcl_Interp *interp, char *name1, char *name2,
  61.                 int flags));
  62. static char *        StringValue _ANSI_ARGS_((Link *linkPtr,
  63.                 char *buffer));
  64.  
  65. /*
  66.  *----------------------------------------------------------------------
  67.  *
  68.  * Tcl_LinkVar --
  69.  *
  70.  *    Link a C variable to a Tcl variable so that changes to either
  71.  *    one causes the other to change.
  72.  *
  73.  * Results:
  74.  *    The return value is TCL_OK if everything went well or TCL_ERROR
  75.  *    if an error occurred (interp->result is also set after errors).
  76.  *
  77.  * Side effects:
  78.  *    The value at *addr is linked to the Tcl variable "varName",
  79.  *    using "type" to convert between string values for Tcl and
  80.  *    binary values for *addr.
  81.  *
  82.  *----------------------------------------------------------------------
  83.  */
  84.  
  85. int
  86. Tcl_LinkVar(interp, varName, addr, type)
  87.     Tcl_Interp *interp;        /* Interpreter in which varName exists. */
  88.     char *varName;        /* Name of a global variable in interp. */
  89.     char *addr;            /* Address of a C variable to be linked
  90.                  * to varName. */
  91.     int type;            /* Type of C variable: TCL_LINK_INT, etc. */
  92. {
  93.     Link *linkPtr;
  94.     char buffer[TCL_DOUBLE_SPACE];
  95.  
  96.     linkPtr = (Link *) ckalloc(sizeof(Link));
  97.     linkPtr->interp = interp;
  98.     linkPtr->addr = addr;
  99.     linkPtr->type = type;
  100.     linkPtr->writable = 1;
  101.     if (Tcl_SetVar(interp, varName, StringValue(linkPtr, buffer),
  102.         TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
  103.     return TCL_ERROR;
  104.     }
  105.     return Tcl_TraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS
  106.         |TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc,
  107.         (ClientData) linkPtr);
  108. }
  109.  
  110. /*
  111.  *----------------------------------------------------------------------
  112.  *
  113.  * Tcl_UnlinkVar --
  114.  *
  115.  *    Destroy the link between a Tcl variable and a C variable.
  116.  *
  117.  * Results:
  118.  *    None.
  119.  *
  120.  * Side effects:
  121.  *    If "varName" was previously linked to a C variable, the link
  122.  *    is broken to make the variable independent.  If there was no
  123.  *    previous link for "varName" then nothing happens.
  124.  *
  125.  *----------------------------------------------------------------------
  126.  */
  127.  
  128. void
  129. Tcl_UnlinkVar(interp, varName)
  130.     Tcl_Interp *interp;        /* Interpreter containing variable to unlink. */
  131.     char *varName;        /* Global variable in interp to unlink. */
  132. {
  133.     Link *linkPtr;
  134.  
  135.     linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
  136.         LinkTraceProc, (ClientData) NULL);
  137.     if (linkPtr == NULL) {
  138.     return;
  139.     }
  140.     Tcl_UntraceVar(interp, varName,
  141.         TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
  142.         LinkTraceProc, (ClientData) linkPtr);
  143.     ckfree((char *) linkPtr);
  144. }
  145.  
  146. /*
  147.  *----------------------------------------------------------------------
  148.  *
  149.  * Tcl_LinkedVarWritable --
  150.  *
  151.  *    Specify whether a linked Tcl variable may be written or not.
  152.  *
  153.  * Results:
  154.  *    None.
  155.  *
  156.  * Side effects:
  157.  *    If "writable" is 0 then varName becomes read-only in interp;
  158.  *    otherwise it is writable.
  159.  *
  160.  *----------------------------------------------------------------------
  161.  */
  162.  
  163. void
  164. Tcl_LinkedVarWritable(interp, varName, writable)
  165.     Tcl_Interp *interp;        /* Interpreter containing linked variable. */
  166.     char *varName;        /* Name of global variable in interp. */
  167.     int writable;        /* 1 means allow varName to be written from
  168.                  * Tcl;  0 means it should be read-only. */
  169. {
  170.     Link *linkPtr;
  171.  
  172.     linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
  173.         LinkTraceProc, (ClientData) NULL);
  174.     if (linkPtr == NULL) {
  175.     return;
  176.     }
  177.     linkPtr->writable = writable;
  178. }
  179.  
  180. /*
  181.  *----------------------------------------------------------------------
  182.  *
  183.  * LinkTraceProc --
  184.  *
  185.  *    This procedure is invoked when a linked Tcl variable is read,
  186.  *    written, or unset from Tcl.  It's responsible for keeping the
  187.  *    C variable in sync with the Tcl variable.
  188.  *
  189.  * Results:
  190.  *    If all goes well, NULL is returned; otherwise an error message
  191.  *    is returned.
  192.  *
  193.  * Side effects:
  194.  *    The C variable may be updated to make it consistent with the
  195.  *    Tcl variable, or the Tcl variable may be overwritten to reject
  196.  *    a modification.
  197.  *
  198.  *----------------------------------------------------------------------
  199.  */
  200.  
  201. static char *
  202. LinkTraceProc(clientData, interp, name1, name2, flags)
  203.     ClientData clientData;    /* Contains information about the link. */
  204.     Tcl_Interp *interp;        /* Interpreter containing Tcl variable. */
  205.     char *name1;        /* First part of variable name. */
  206.     char *name2;        /* Second part of variable name. */
  207.     int flags;            /* Miscellaneous additional information. */
  208. {
  209.     Link *linkPtr = (Link *) clientData;
  210.     int changed;
  211.     char buffer[TCL_DOUBLE_SPACE];
  212.     char *value, **pp;
  213.     Tcl_DString savedResult;
  214.  
  215.     /*
  216.      * If the variable is being unset, then just re-create it (with a
  217.      * trace) unless the whole interpreter is going away.
  218.      */
  219.  
  220.     if (flags & TCL_TRACE_UNSETS) {
  221.     if (flags & TCL_INTERP_DESTROYED) {
  222.         ckfree((char *) linkPtr);
  223.     }
  224.     if (flags & TCL_TRACE_DESTROYED) {
  225.         Tcl_SetVar2(interp, name1, name2,
  226.             StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY);
  227.         Tcl_TraceVar2(interp, name1, name2, TCL_GLOBAL_ONLY
  228.             |TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
  229.             LinkTraceProc, (ClientData) linkPtr);
  230.     }
  231.     return NULL;
  232.     }
  233.  
  234.     /*
  235.      * For read accesses, update the Tcl variable if the C variable
  236.      * has changed since the last time we updated the Tcl variable.
  237.      */
  238.  
  239.     if (flags & TCL_TRACE_READS) {
  240.     switch (linkPtr->type) {
  241.         case TCL_LINK_INT:
  242.         case TCL_LINK_BOOLEAN:
  243.         changed = *(int *)(linkPtr->addr) != linkPtr->lastValue.i;
  244.         break;
  245.         case TCL_LINK_DOUBLE:
  246.         changed = *(double *)(linkPtr->addr) != linkPtr->lastValue.d;
  247.         break;
  248.         case TCL_LINK_STRING:
  249.         changed = 1;
  250.         break;
  251.         default:
  252.         return "internal error: bad linked variable type";
  253.     }
  254.     if (changed) {
  255.         Tcl_SetVar2(interp, name1, name2, StringValue(linkPtr, buffer),
  256.             TCL_GLOBAL_ONLY);
  257.     }
  258.     return NULL;
  259.     }
  260.  
  261.     /*
  262.      * For writes, first make sure that the variable is writable.  Then
  263.      * convert the Tcl value to C if possible.  If the variable isn't
  264.      * writable or can't be converted, then restore the varaible's old
  265.      * value and return an error.  Another tricky thing: we have to save
  266.      * and restore the interpreter's result, since the variable access
  267.      * could occur when the result has been partially set.
  268.      */
  269.  
  270.     if (!linkPtr->writable) {
  271.     Tcl_SetVar2(interp, name1, name2, StringValue(linkPtr, buffer),
  272.             TCL_GLOBAL_ONLY);
  273.     return "linked variable is read-only";
  274.     }
  275.     value = Tcl_GetVar2(interp, name1, name2, TCL_GLOBAL_ONLY);
  276.     if (value == NULL) {
  277.     /*
  278.      * This shouldn't ever happen.
  279.      */
  280.     return "internal error: linked variable couldn't be read";
  281.     }
  282.     Tcl_DStringInit(&savedResult);
  283.     Tcl_DStringAppend(&savedResult, interp->result, -1);
  284.     Tcl_ResetResult(interp);
  285.     switch (linkPtr->type) {
  286.     case TCL_LINK_INT:
  287.         if (Tcl_GetInt(interp, value, &linkPtr->lastValue.i) != TCL_OK) {
  288.         Tcl_DStringResult(interp, &savedResult);
  289.         Tcl_SetVar2(interp, name1, name2, StringValue(linkPtr, buffer),
  290.             TCL_GLOBAL_ONLY);
  291.         return "variable must have integer value";
  292.         }
  293.         *(int *)(linkPtr->addr) = linkPtr->lastValue.i;
  294.         break;
  295.     case TCL_LINK_DOUBLE:
  296.         if (Tcl_GetDouble(interp, value, &linkPtr->lastValue.d)
  297.             != TCL_OK) {
  298.         Tcl_DStringResult(interp, &savedResult);
  299.         Tcl_SetVar2(interp, name1, name2, StringValue(linkPtr, buffer),
  300.             TCL_GLOBAL_ONLY);
  301.         return "variable must have real value";
  302.         }
  303.         *(double *)(linkPtr->addr) = linkPtr->lastValue.d;
  304.         break;
  305.     case TCL_LINK_BOOLEAN:
  306.         if (Tcl_GetBoolean(interp, value, &linkPtr->lastValue.i)
  307.             != TCL_OK) {
  308.         Tcl_DStringResult(interp, &savedResult);
  309.         Tcl_SetVar2(interp, name1, name2, StringValue(linkPtr, buffer),
  310.             TCL_GLOBAL_ONLY);
  311.         return "variable must have boolean value";
  312.         }
  313.         *(int *)(linkPtr->addr) = linkPtr->lastValue.i;
  314.         break;
  315.     case TCL_LINK_STRING:
  316.         pp = (char **)(linkPtr->addr);
  317.         if (*pp != NULL) {
  318.         ckfree(*pp);
  319.         }
  320.         *pp = ckalloc((unsigned) (strlen(value) + 1));
  321.         strcpy(*pp, value);
  322.         break;
  323.     default:
  324.         return "internal error: bad linked variable type";
  325.     }
  326.     Tcl_DStringResult(interp, &savedResult);
  327.     return NULL;
  328. }
  329.  
  330. /*
  331.  *----------------------------------------------------------------------
  332.  *
  333.  * StringValue --
  334.  *
  335.  *    Converts the value of a C variable to a string for use in a
  336.  *    Tcl variable to which it is linked.
  337.  *
  338.  * Results:
  339.  *    The return value is a pointer
  340.  to a string that represents
  341.  *    the value of the C variable given by linkPtr.
  342.  *
  343.  * Side effects:
  344.  *    None.
  345.  *
  346.  *----------------------------------------------------------------------
  347.  */
  348.  
  349. static char *
  350. StringValue(linkPtr, buffer)
  351.     Link *linkPtr;        /* Structure describing linked variable. */
  352.     char *buffer;        /* Small buffer to use for converting
  353.                  * values.  Must have TCL_DOUBLE_SPACE
  354.                  * bytes or more. */
  355. {
  356.     char *p;
  357.  
  358.     switch (linkPtr->type) {
  359.     case TCL_LINK_INT:
  360.         linkPtr->lastValue.i = *(int *)(linkPtr->addr);
  361.         sprintf(buffer, "%d", linkPtr->lastValue.i);
  362.         return buffer;
  363.     case TCL_LINK_DOUBLE:
  364.         linkPtr->lastValue.d = *(double *)(linkPtr->addr);
  365.         Tcl_PrintDouble(linkPtr->interp, linkPtr->lastValue.d, buffer);
  366.         return buffer;
  367.     case TCL_LINK_BOOLEAN:
  368.         linkPtr->lastValue.i = *(int *)(linkPtr->addr);
  369.         if (linkPtr->lastValue.i != 0) {
  370.         return "1";
  371.         }
  372.         return "0";
  373.     case TCL_LINK_STRING:
  374.         p = *(char **)(linkPtr->addr);
  375.         if (p == NULL) {
  376.         return "NULL";
  377.         }
  378.         return p;
  379.     }
  380.  
  381.     /*
  382.      * This code only gets executed if the link type is unknown
  383.      * (shouldn't ever happen).
  384.      */
  385.  
  386.     return "??";
  387. }
  388.